Figures and tables based on ideo motive analyses (secondary)

Preparations

Load models

# pol models (across performance and neutral)
m1.pol <- readRDS(file = here(pol_model_dir, "m1.pol.rds"))
m2.pol <- readRDS(file = here(pol_model_dir, "m2.pol.rds"))
m3.pol <- readRDS(file = here(pol_model_dir, "m3.pol.rds"))
m4.pol <- readRDS(file = here(pol_model_dir, "m4.pol.rds"))
m5.pol <- readRDS(file = here(pol_model_dir, "m5.pol.rds"))
m6.pol <- readRDS(file = here(pol_model_dir, "m6.pol.rds"))

# performance models
m1.per <- readRDS(file = here(nonpol_model_dir, "m1.per.rds"))
m2.per <- readRDS(file = here(nonpol_model_dir, "m2.per.rds"))
m3.per <- readRDS(file = here(nonpol_model_dir, "m3.per.rds"))
m4.per <- readRDS(file = here(nonpol_model_dir, "m4.per.rds"))
m5.per <- readRDS(file = here(nonpol_model_dir, "m5.per.rds"))
m6.per <- readRDS(file = here(nonpol_model_dir, "m6.per.rds"))

# neutral models
m1.neu <- readRDS(file = here(nonpol_model_dir, "m1.neu.rds"))
m2.neu <- readRDS(file = here(nonpol_model_dir, "m2.neu.rds"))
m3.neu <- readRDS(file = here(nonpol_model_dir, "m3.neu.rds"))
m4.neu <- readRDS(file = here(nonpol_model_dir, "m4.neu.rds"))
m5.neu <- readRDS(file = here(nonpol_model_dir, "m5.neu.rds"))
m6.neu <- readRDS(file = here(nonpol_model_dir, "m6.neu.rds"))

Load original data

data_path <- here("01_data", "analysis", "data_analysis.RData")
load(file = data_path)

Filters

initial_rows <- nrow(data_analysis)
data_prep <- data_analysis %>% 
  filter(Screen != "Question")
filtered_rows <- initial_rows - nrow(data_prep)

filtered_rows

[1] 5389

data_full <- data_prep %>% 
  filter(question_type %in% c("political", "performance", "nonpolitical")) %>% 
  mutate(question_topic = factor(question_topic, 
                                 levels = c("climate",
                                            "gender",
                                            "immigration",
                                            "discrimination",
                                            "adoption",
                                            "punishment",
                                            "gonogo_performance", 
                                            "fakenews_performance",
                                            "teaculture",
                                            "brain"))) %>%
  droplevels()   

unique(data_full$question_topic)

 [1] adoption             climate              punishment           gender              
 [5] discrimination       gonogo_performance   immigration          teaculture          
 [9] fakenews_performance brain               
10 Levels: climate gender immigration discrimination adoption ... brain

Data types

data_full <- data_full %>%
  mutate(ideo_motive_strength = factor(ideo_motive_strength,
                                        levels = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Neutral",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                                        ordered = TRUE)) 

Data for submodels

data_pol <- data_full %>% 
  filter(question_type == "political") %>% 
  droplevels() 

data_per <- data_full %>% 
  filter(question_type == "performance") %>% 
  droplevels()   

data_neu <- data_full %>% 
  filter(question_type == "nonpolitical") %>% 
  droplevels()  

unique(data_pol$question_topic)

[1] adoption       climate        punishment     gender         discrimination
[6] immigration   
Levels: climate gender immigration discrimination adoption punishment

unique(data_per$question_topic)

[1] gonogo_performance   fakenews_performance
Levels: gonogo_performance fakenews_performance

unique(data_neu$question_topic)

[1] teaculture brain     
Levels: teaculture brain

Table 1: Parameter estimates of interest m1, m3, m4 (logit)

Create a logit table with main parameters of interest of m1, m3, m4.

m1 table

h0a.pol <- hypothesis(m1.pol, "ideo_motivePro > 0",
                      alpha = 0.025,
                      seed = 42)

h0a.per <- hypothesis(m1.per, "ideo_motivePro > 0",
                      alpha = 0.025,
                      seed = 42)

h0a.neu <- hypothesis(m1.neu, "ideo_motivePro > 0",
                      alpha = 0.025,
                      seed = 42)

h0a.pol$hypothesis$Evid.Ratio

[1] 54.2

h0a.per$hypothesis$Evid.Ratio

[1] 7999

h0a.neu$hypothesis$Evid.Ratio

[1] 1.05

h0b.pol <- hypothesis(m1.pol, "ideo_motivePro < 0",
                      alpha = 0.025,
                      seed = 42)

h0b.per <- hypothesis(m1.per, "ideo_motivePro < 0",
                      alpha = 0.025,
                      seed = 42)

h0b.neu <- hypothesis(m1.neu, "ideo_motivePro < 0",
                      alpha = 0.025,
                      seed = 42)

h0b.pol$hypothesis$Evid.Ratio

[1] 0.0185

h0b.per$hypothesis$Evid.Ratio

[1] 0.000125

h0b.neu$hypothesis$Evid.Ratio

[1] 0.95

m1.pol.logit <- describe_posterior(m1.pol, centrality = "median",
                                  ci = 0.95, ci_method = "eti",
                                  diagnostic = c("Rhat"), effects = c("fixed"),
                                  dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h0a.pol$hypothesis$Evid.Ratio,
         "β < 0" = h0b.pol$hypothesis$Evid.Ratio)

m1.per.logit <- describe_posterior(m1.per, centrality = "median",
                                  ci = 0.95, ci_method = "eti",
                                  diagnostic = c("Rhat"), effects = c("fixed"),
                                  dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h0a.per$hypothesis$Evid.Ratio,
         "β < 0" = h0b.per$hypothesis$Evid.Ratio)

m1.neu.logit <- describe_posterior(m1.neu, centrality = "median",
                                  ci = 0.95, ci_method = "eti",
                                  diagnostic = c("Rhat"), effects = c("fixed"),
                                  dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h0a.neu$hypothesis$Evid.Ratio,
         "β < 0" = h0b.neu$hypothesis$Evid.Ratio)

m1.logit <- bind_rows(m1.pol.logit, m1.per.logit, m1.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "b_ideo_motivePro") %>% 
  mutate(Parameter = "Motive (Pro > Anti)") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m1.logit

Summary of Posterior Distribution

Question Type |           Parameter |   Median |    LL |   UL |   β > 0 | β < 0
-------------------------------------------------------------------------------
Political     | Motive (Pro > Anti) |     0.22 |  0.03 | 0.41 |   54.17 |  0.02
Performance   | Motive (Pro > Anti) |     0.22 |  0.10 | 0.34 | 7999.00 |  0.00
Neutral       | Motive (Pro > Anti) | 2.00e-03 | -0.14 | 0.14 |    1.05 |  0.95

m3 table

h1a.pol <- hypothesis(m3.pol, "ideo_motivePro:scalecrt_correct > 0",
                                alpha = 0.025,
                                seed = 42)

h1a.per <- hypothesis(m3.per, "ideo_motivePro:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a.neu <- hypothesis(m3.neu, "ideo_motivePro:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a.pol$hypothesis$Evid.Ratio

[1] 0.94

h1a.per$hypothesis$Evid.Ratio

[1] 19.6

h1a.neu$hypothesis$Evid.Ratio

[1] 0.955

h1b.pol <- hypothesis(m3.pol, "ideo_motivePro:scalecrt_correct < 0",
                      alpha = 0.025,
                      seed = 42)

h1b.per <- hypothesis(m3.per, "ideo_motivePro:scalecrt_correct < 0", 
                      alpha = 0.025,
                      seed = 42)

h1b.neu <- hypothesis(m3.neu, "ideo_motivePro:scalecrt_correct < 0", 
                      alpha = 0.025,
                      seed = 42)

h1b.pol$hypothesis$Evid.Ratio

[1] 1.06

h1b.per$hypothesis$Evid.Ratio

[1] 0.0511

h1b.neu$hypothesis$Evid.Ratio

[1] 1.05

m3.pol.logit <- describe_posterior(m3.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h1a.pol$hypothesis$Evid.Ratio,
         "β < 0" = h1b.pol$hypothesis$Evid.Ratio)

m3.per.logit <- describe_posterior(m3.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h1a.per$hypothesis$Evid.Ratio,
         "β < 0" = h1b.per$hypothesis$Evid.Ratio)

m3.neu.logit <- describe_posterior(m3.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h1a.neu$hypothesis$Evid.Ratio,
         "β < 0" = h1b.neu$hypothesis$Evid.Ratio)

m3.logit <- bind_rows(m3.pol.logit, m3.per.logit, m3.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "b_ideo_motivePro:scalecrt_correct") %>% 
  mutate(Parameter = "Motive x Cognitive Reflection") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m3.logit

Summary of Posterior Distribution

Question Type |                     Parameter |    Median |    LL |   UL | β > 0 | β < 0
----------------------------------------------------------------------------------------
Political     | Motive x Cognitive Reflection | -2.00e-03 | -0.07 | 0.07 |  0.94 |  1.06
Performance   | Motive x Cognitive Reflection |      0.11 | -0.02 | 0.23 | 19.57 |  0.05
Neutral       | Motive x Cognitive Reflection | -2.00e-03 | -0.14 | 0.14 |  0.95 |  1.05

m4 table

h2a.pol <- hypothesis(m4.pol, "ideo_motivePro:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a.per <- hypothesis(m4.per, "ideo_motivePro:scalecommission_errors_r > 0", 
                      alpha = 0.025,
                      seed = 42)

h2a.neu <- hypothesis(m4.neu, "ideo_motivePro:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a.pol$hypothesis$Evid.Ratio

[1] 1.17

h2a.per$hypothesis$Evid.Ratio

[1] 72.4

h2a.neu$hypothesis$Evid.Ratio

[1] 1.19

h2b.pol <- hypothesis(m4.pol, "ideo_motivePro:scalecommission_errors_r < 0",
                      alpha = 0.025,
                      seed = 42)

h2b.per <- hypothesis(m4.per, "ideo_motivePro:scalecommission_errors_r < 0", 
                      alpha = 0.025,
                      seed = 42)

h2b.neu <- hypothesis(m4.neu, "ideo_motivePro:scalecommission_errors_r < 0",
                      alpha = 0.025,
                      seed = 42)

h2b.pol$hypothesis$Evid.Ratio

[1] 0.855

h2b.per$hypothesis$Evid.Ratio

[1] 0.0138

h2b.neu$hypothesis$Evid.Ratio

[1] 0.839

m4.pol.logit <- describe_posterior(m4.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h2a.pol$hypothesis$Evid.Ratio,
         "β < 0" = h2b.pol$hypothesis$Evid.Ratio)

m4.per.logit <- describe_posterior(m4.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h2a.per$hypothesis$Evid.Ratio,
         "β < 0" = h2b.per$hypothesis$Evid.Ratio)

m4.neu.logit <- describe_posterior(m4.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h2a.neu$hypothesis$Evid.Ratio,
         "β < 0" = h2b.neu$hypothesis$Evid.Ratio)

m4.logit <- bind_rows(m4.pol.logit, m4.per.logit, m4.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "b_ideo_motivePro:scalecommission_errors_r") %>% 
  mutate(Parameter = "Motive x Inhibitory Control") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m4.logit

Summary of Posterior Distribution

Question Type |                   Parameter |   Median |    LL |   UL | β > 0 | β < 0
-------------------------------------------------------------------------------------
Political     | Motive x Inhibitory Control | 4.00e-03 | -0.07 | 0.08 |  1.17 |  0.85
Performance   | Motive x Inhibitory Control |     0.14 |  0.01 | 0.26 | 72.39 |  0.01
Neutral       | Motive x Inhibitory Control | 8.00e-03 | -0.13 | 0.14 |  1.19 |  0.84

Combined table

combined_logit <- bind_rows(m1.logit, m3.logit, m4.logit) %>% 
  mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>% 
  arrange(`Question Type`, Parameter)

combined_logit_table <- combined_logit %>% 
  select(-c("Question Type")) %>% 
  tt() %>% 
  group_tt(
    i = list(
      "Political Vignettes" = 1,
      "Performance Vignettes" = 4,
      "Neutral Vignettes" = 7
    ),
    j = list(
      "95% CI" = 3:4,
      "Evidence Ratio" = 5:6))

combined_logit_table %>% save_tt(here(table_dir, "combined_logit_table.docx"), overwrite = TRUE)

combined_logit_table

		95% CI		Evidence Ratio
Parameter	Median	LL	UL	β > 0	β < 0
Motive (Pro > Anti)	0.220	0.027	0.410	54.172	0.018
Motive x Cognitive Reflection	-0.002	-0.074	0.072	0.940	1.064
Motive x Inhibitory Control	0.004	-0.069	0.076	1.169	0.855
Motive (Pro > Anti)	0.221	0.100	0.345	7999.000	0.000
Motive x Cognitive Reflection	0.108	-0.019	0.230	19.566	0.051
Motive x Inhibitory Control	0.140	0.014	0.263	72.394	0.014
Motive (Pro > Anti)	0.002	-0.136	0.140	1.053	0.950
Motive x Cognitive Reflection	-0.002	-0.136	0.138	0.955	1.048
Motive x Inhibitory Control	0.008	-0.128	0.141	1.192	0.839

Main Text: Reported Percentage Predictions m1, m3

m1: Pro vs. Anti in %

Calculate % comparisons

m1.pol.com <- m1.pol %>% 
  avg_comparisons() %>% 
  as_tibble() %>% 
  select(contrast, estimate, conf.low, conf.high) %>%
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(contrast = recode(contrast,
                           "mean(Pro) - mean(Anti)" = "Pro - Anti"),
         "Question Type" = "Political") %>%
  rename("Contrast" = "contrast",
         "Estimate" = "estimate",
         "LL" = "conf.low",
         "UL" = "conf.high")

m1.per.com <- m1.per %>% 
  avg_comparisons() %>% 
  as_tibble() %>% 
  select(contrast, estimate, conf.low, conf.high) %>%
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(contrast = recode(contrast,
                           "mean(Pro) - mean(Anti)" = "Pro - Anti"),
         "Question Type" = "Performance") %>%
  rename("Contrast" = "contrast",
         "Estimate" = "estimate",
         "LL" = "conf.low",
         "UL" = "conf.high")

m1.neu.com <- m1.neu %>% 
  avg_comparisons() %>% 
  as_tibble() %>% 
  select(contrast, estimate, conf.low, conf.high) %>%
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(contrast = recode(contrast,
                           "mean(Pro) - mean(Anti)" = "Pro - Anti"),
         "Question Type" = "Neutral") %>%
  rename("Contrast" = "contrast",
         "Estimate" = "estimate",
         "LL" = "conf.low",
         "UL" = "conf.high")

Combined table

m1.combined_perc <- bind_rows(m1.pol.com, m1.per.com, m1.neu.com) %>% 
  mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) 

m1.combined_perc_table <- m1.combined_perc %>% 
  select(-c("Question Type")) %>% 
  tt() %>% 
  group_tt(
    i = list(
      "Political Vignettes" = 1,
      "Performance Vignettes" = 2,
      "Neutral Vignettes" = 3
    ),
    j = list(
      "95% CI" = 3:4))

m1.combined_perc_table %>% save_tt(here(table_dir, "m1_combined_perc_table.docx"), overwrite = TRUE)

m1.combined_perc_table

		95% CI
Contrast	Estimate	LL	UL
Pro - Anti	0.05602	0.0383	0.0736
Pro - Anti	0.05612	0.0264	0.0859
Pro - Anti	-0.00334	-0.0370	0.0307

m3: Pro vs. Anti for CRT = 3 and CRT = 0 in %

crt.newdata <- 
  expand_grid(ideo_motive = c("Pro", "Anti"),
              crt_correct = c(0, 3))

m3.pol.com <- m3.pol %>%
    epred_draws(newdata = crt.newdata,
                re_formula = NA) %>% 
    group_by(crt_correct) %>% 
    compare_levels(.epred, by = ideo_motive) %>% 
    compare_levels(.epred, by = crt_correct) %>% 
    median_qi(.width = 0.95)

m3.pol.com %>% tt()

crt_correct	ideo_motive	.epred	.lower	.upper	.width	.point	.interval
3 - 0	Pro - Anti	-0.00132	-0.0492	0.0472	0.95	median	qi

Figure: Motivated Reasoning on Different Topics

Extract draws

Average effect of motivated reasoning on political, performance, and neutral topics

m1.pol.draws <- m1.pol %>%
  avg_comparisons(variables = "ideo_motive") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Political",
         question_topic = "average")

m1.pol.draws %>% median_hdi(draw)

# A tibble: 1 × 6
    draw .lower .upper .width .point .interval
   <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 0.0560 0.0379 0.0730   0.95 median hdi      

m1.per.draws <- m1.per %>%
  avg_comparisons(variables = "ideo_motive") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Performance",
         question_topic = "average")

m1.per.draws %>% median_hdi(draw)

# A tibble: 1 × 6
    draw .lower .upper .width .point .interval
   <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 0.0561 0.0267 0.0860   0.95 median hdi      

m1.neu.draws <- m1.neu %>%
  avg_comparisons(variables = "ideo_motive") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Neutral",
         question_topic = "average")

m1.neu.draws %>% median_hdi(draw)

# A tibble: 1 × 6
      draw  .lower .upper .width .point .interval
     <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 -0.00334 -0.0370 0.0307   0.95 median hdi      

Motivated reasoning by topic

m1.pol.topic <- avg_comparisons(m1.pol,
                                variables = "ideo_motive",
                                by = "question_topic") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Political")
  
m1.pol.topic %>% group_by(question_topic) %>% median_hdi(draw)

# A tibble: 6 × 7
  question_topic   draw  .lower .upper .width .point .interval
  <fct>           <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 climate        0.0545  0.0179 0.0890   0.95 median hdi      
2 gender         0.0244 -0.0139 0.0616   0.95 median hdi      
3 immigration    0.0913  0.0533 0.126    0.95 median hdi      
4 discrimination 0.0871  0.0477 0.127    0.95 median hdi      
5 adoption       0.0597  0.0240 0.0943   0.95 median hdi      
6 punishment     0.0205 -0.0187 0.0590   0.95 median hdi      

m1.per.topic <- avg_comparisons(m1.per,
                                variables = "ideo_motive",
                                by = "question_topic") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Performance")
  
m1.per.topic %>% group_by(question_topic) %>% median_hdi(draw)

# A tibble: 2 × 7
  question_topic         draw  .lower .upper .width .point .interval
  <fct>                 <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 gonogo_performance   0.0665 0.0223  0.106    0.95 median hdi      
2 fakenews_performance 0.0456 0.00326 0.0869   0.95 median hdi      

m1.neu.topic <- avg_comparisons(m1.neu,
                                variables = "ideo_motive",
                                by = "question_topic") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Neutral")
  
m1.neu.topic %>% group_by(question_topic) %>% median_hdi(draw)

# A tibble: 2 × 7
  question_topic    draw   .lower  .upper .width .point .interval
  <fct>            <dbl>    <dbl>   <dbl>  <dbl> <chr>  <chr>    
1 teaculture     -0.0414 -0.0870  0.00307   0.95 median hdi      
2 brain           0.0412 -0.00770 0.0915    0.95 median hdi      

Create a combined dataframe

m1.combined <- bind_rows(m1.pol.draws, m1.pol.topic, 
                         m1.per.draws, m1.per.topic,
                         m1.neu.draws, m1.neu.topic)

m1.combined <- m1.combined %>% 
  mutate(question_topic = factor(question_topic,
                                 levels = c("brain",
                                            "teaculture", 
                                            "fakenews_performance", 
                                            "gonogo_performance",
                                            "punishment",
                                            "adoption", 
                                            "discrimination",
                                            "gender",
                                            "immigration",
                                            "climate", 
                                            "average"),
                                 labels = c("Brain proportion",
                                            "Tea with milk",
                                            "Fake News performance",
                                            "Go / No-Go performance",
                                            "Criminal reconviction",
                                            "Same-sex adoption",
                                            "Racial discrimination",
                                            "Gender stereotypes",
                                            "Immigrant population",
                                            "Anthropogenic climate change",
                                            "Average"
                                            )),
         draw_perc = draw*100) 

Create figure

average_color <- "#645CAA"

plot_political <- m1.combined %>%
  filter(question_type == "Political") %>%
  ggplot(aes(x = draw_perc, y = question_topic, 
             fill = question_topic == "Average")) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#A685E2")) +
  labs(subtitle = "Political Vignettes",
       x = NULL, y = NULL) +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25),
                     breaks = seq(-10, 20, by = 5)) +
  theme_ipsum_rc(base_size = 16,
                 subtitle_size = 18,
                 subtitle_face = "bold",
                 axis_text_size = 16,
                 grid = "XY") +
  guides(fill = "none") +
  theme(legend.position = "none")

plot_performance <- m1.combined %>%
  filter(question_type == "Performance") %>%
  ggplot(aes(x = draw_perc, y = question_topic, 
             fill = question_topic == "Average")) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FF8DC7")) +
  labs(subtitle = "Performance Vignettes",
       x = NULL, y = NULL) +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
  theme_ipsum_rc(base_size = 16,
                 subtitle_size = 18,
                 subtitle_face = "bold",
                 axis_text_size = 16,
                 grid = "XY") +
  guides(fill = "none") +
  theme(legend.position = "none")

plot_neutral <- m1.combined %>%
  filter(question_type == "Neutral") %>%
  ggplot(aes(x = draw_perc, y = question_topic, 
             fill = question_topic == "Average")) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FFABE1")) +
  labs(subtitle = "Neutral Vignettes",
       x = NULL, y = NULL) +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
  theme_ipsum_rc(base_size = 16,
                 subtitle_size = 18,
                 subtitle_face = "bold",
                 axis_text_size = 16,
                 grid = "XY") +
  guides(fill = "none") +
  theme(legend.position = "none")

main_effect_plot <- plot_political / (plot_performance | plot_neutral) +
  plot_layout(heights = c(2, 1))

main_effect_plot

Warning: Removed 38 rows containing missing values or values outside the scale range
(`stat_slabinterval()`).

ggsave(here(fig_dir, "m1_main_fig.png"), width = 12, height = 10, dpi = 300)

Warning: Removed 38 rows containing missing values or values outside the scale range
(`stat_slabinterval()`).

Figure: The link to cognitive control variables

Extract political draws

m3.pol.draws <- avg_comparisons(m3.pol,
                   variables = "ideo_motive",
                   by = "crt_correct") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") 

m3.pol.draws %>% group_by(crt_correct) %>% median_hdi(draw)

# A tibble: 4 × 7
  crt_correct   draw .lower .upper .width .point .interval
        <dbl>  <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
1    2.22e-16 0.0575 0.0256 0.0868   0.95 median hdi      
2    1   e+ 0 0.0558 0.0335 0.0797   0.95 median hdi      
3    2   e+ 0 0.0551 0.0331 0.0750   0.95 median hdi      
4    3   e+ 0 0.0567 0.0303 0.0833   0.95 median hdi      

m4.pol.draws <- avg_comparisons(m4.pol,
                   variables = "ideo_motive",
                   by = "commission_errors_r",
                   newdata = expand_grid(ideo_motive = c("Pro", "Anti"),
                                         commission_errors_r = seq(13, 56)),
                   re_formula = NA) %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") 

Warning: The `ideo_motive` variable is treated as a categorical (factor) variable, but the
  original data is of class character. It is safer and faster to convert such
  variables to factor before fitting the model and calling a `marginaleffects`
  function.
  
  This warning appears once per session.

m4.pol.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)

# A tibble: 44 × 7
   commission_errors_r   draw   .lower .upper .width .point .interval
                 <int>  <dbl>    <dbl>  <dbl>  <dbl> <chr>  <chr>    
 1                  13 0.0546 -0.0148   0.129   0.95 median hdi      
 2                  14 0.0547 -0.0150   0.125   0.95 median hdi      
 3                  15 0.0549 -0.0125   0.124   0.95 median hdi      
 4                  16 0.0551 -0.0111   0.123   0.95 median hdi      
 5                  17 0.0551 -0.0114   0.120   0.95 median hdi      
 6                  18 0.0553 -0.0104   0.117   0.95 median hdi      
 7                  19 0.0555 -0.00811  0.117   0.95 median hdi      
 8                  20 0.0556 -0.00743  0.115   0.95 median hdi      
 9                  21 0.0555 -0.00392  0.115   0.95 median hdi      
10                  22 0.0557 -0.00139  0.114   0.95 median hdi      
# ℹ 34 more rows

Create political figures

pol_crt_plot <- m3.pol.draws %>%
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
  stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),  
    .width = c(0.5, 0.95), 
    alpha = 0.7,
    position = position_dodge(width = 0.5)) +
  scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
  labs(title = "Cognitive Reflection and Motivated Reasoning",
    subtitle = glue("Political vignettes (Evid.Ratio H1a > H1b = {round(h1a.pol$hypothesis$Evid.Ratio, 2)})"),
    x = "Cognitive Reflection",
    y = "Motivated Reasoning") +
  scale_x_continuous(breaks = c(0, 1, 2, 3)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 plot_title_face = "bold",
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY") +
  theme(legend.position = "none")

pol_crt_plot

alt_pol_crt_plot <- m3.pol.draws %>% 
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = crt_correct, y = draw_perc)) +
  stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) + 
  scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
  labs(title = "Cognitive Reflection and Motivated Reasoning",
    subtitle = glue("Political vignettes (Evid.Ratio H2a > H2b = {round(h1a.pol$hypothesis$Evid.Ratio, 2)})"),
       x = "Cognitive Reflection", 
       y = "Motivated Reasoning",
       fill = "Credible interval") +
  scale_x_continuous(breaks = c(0, 1, 2, 3)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 plot_title_face = "bold",
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY"
                 ) +
  theme(legend.position = "top")

alt_pol_crt_plot

pol_gng_plot <- m4.pol.draws %>% 
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = commission_errors_r, y = draw_perc)) +
  stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) + 
  scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
  labs(title = "Inhibitory Control and Motivated Reasoning",
    subtitle = glue("Political vignettes (Evid.Ratio H2a > H2b = {round(h2a.pol$hypothesis$Evid.Ratio, 2)})"),
       x = "Inhibitory Control", 
       y = "Motivated Reasoning",
       fill = "Credible interval") +
  scale_x_continuous(breaks = seq(15, 55, by = 10)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 plot_title_face = "bold",
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY"
                 ) +
  theme(legend.position = "top")

pol_gng_plot

Extract performance and neutral draws

m3.per.draws <- avg_comparisons(m3.per,
                   variables = "ideo_motive",
                   by = "crt_correct") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") 

m3.per.draws %>% group_by(crt_correct) %>% median_hdi(draw)

# A tibble: 4 × 7
  crt_correct   draw   .lower .upper .width .point .interval
        <dbl>  <dbl>    <dbl>  <dbl>  <dbl> <chr>  <chr>    
1    2.22e-16 0.0190 -0.0315  0.0713   0.95 median hdi      
2    1   e+ 0 0.0431  0.00785 0.0829   0.95 median hdi      
3    2   e+ 0 0.0658  0.0295  0.101    0.95 median hdi      
4    3   e+ 0 0.0880  0.0414  0.136    0.95 median hdi      

m3.neu.draws <- avg_comparisons(m3.neu,
                   variables = "ideo_motive",
                   by = "crt_correct") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") 

m3.neu.draws %>% group_by(crt_correct) %>% median_hdi(draw)

# A tibble: 4 × 7
  crt_correct     draw  .lower .upper .width .point .interval
        <dbl>    <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1           0 -0.00161 -0.0573 0.0608   0.95 median hdi      
2           1 -0.00127 -0.0431 0.0395   0.95 median hdi      
3           2 -0.00719 -0.0466 0.0284   0.95 median hdi      
4           3 -0.00334 -0.0512 0.0509   0.95 median hdi      

m4.per.draws <- avg_comparisons(m4.per,
                   variables = "ideo_motive",
                   by = "commission_errors_r",
                   newdata = expand_grid(ideo_motive = c("Pro", "Anti"),
                                         commission_errors_r = seq(13, 56),
                                         question_topic = levels(data_per$question_topic)),
                   re_formula = NA) %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") 

m4.per.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)

# A tibble: 44 × 7
   commission_errors_r     draw  .lower .upper .width .point .interval
                 <int>    <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
 1                  13 -0.0486  -0.145  0.0516   0.95 median hdi      
 2                  14 -0.0442  -0.136  0.0530   0.95 median hdi      
 3                  15 -0.0399  -0.130  0.0531   0.95 median hdi      
 4                  16 -0.0357  -0.122  0.0532   0.95 median hdi      
 5                  17 -0.0315  -0.114  0.0551   0.95 median hdi      
 6                  18 -0.0271  -0.106  0.0554   0.95 median hdi      
 7                  19 -0.0228  -0.0996 0.0556   0.95 median hdi      
 8                  20 -0.0184  -0.0939 0.0540   0.95 median hdi      
 9                  21 -0.0140  -0.0853 0.0556   0.95 median hdi      
10                  22 -0.00963 -0.0773 0.0573   0.95 median hdi      
# ℹ 34 more rows

m4.neu.draws <- avg_comparisons(m4.neu,
                   variables = "ideo_motive",
                   by = "commission_errors_r",
                   newdata = expand_grid(ideo_motive = c("Pro", "Anti"),
                                         commission_errors_r = seq(13, 56),
                                         question_topic = levels(data_neu$question_topic)),
                   re_formula = NA) %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") 

m4.neu.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)

# A tibble: 44 × 7
   commission_errors_r     draw  .lower .upper .width .point .interval
                 <int>    <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
 1                  13 -0.00479 -0.106  0.106    0.95 median hdi      
 2                  14 -0.00456 -0.113  0.0921   0.95 median hdi      
 3                  15 -0.00419 -0.0988 0.0987   0.95 median hdi      
 4                  16 -0.00424 -0.0948 0.0953   0.95 median hdi      
 5                  17 -0.00413 -0.0919 0.0906   0.95 median hdi      
 6                  18 -0.00382 -0.0872 0.0876   0.95 median hdi      
 7                  19 -0.00355 -0.0836 0.0842   0.95 median hdi      
 8                  20 -0.00321 -0.0793 0.0809   0.95 median hdi      
 9                  21 -0.00311 -0.0760 0.0774   0.95 median hdi      
10                  22 -0.00265 -0.0723 0.0739   0.95 median hdi      
# ℹ 34 more rows

Create performance and neutral figures

per_crt_plot <- m3.per.draws %>%
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
  stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),  
    .width = c(0.5, 0.95), 
    alpha = 0.7,
    position = position_dodge(width = 0.5)) +
  scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
  labs(subtitle = glue("Performance vignettes 
(Evid.Ratio H1a > H1b = {round(h1a.per$hypothesis$Evid.Ratio, 2)})"),
       x = NULL, 
       y = NULL) +
  scale_x_continuous(breaks = c(0, 1, 2, 3)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY") +
  theme(legend.position = "none")

per_crt_plot

alt_per_crt_plot <- m3.per.draws %>% 
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = crt_correct, y = draw_perc)) +
  stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) + 
  scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
  labs(subtitle = glue("Performance vignettes 
(Evid.Ratio H1a > H1b = {round(h1a.per$hypothesis$Evid.Ratio, 2)})"),
       x = NULL, 
       y = NULL) +
  scale_x_continuous(breaks = c(0, 1, 2, 3)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY") +
  theme(legend.position = "none")

alt_per_crt_plot

neu_crt_plot <- m3.neu.draws %>%
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
  stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),  
    .width = c(0.5, 0.95), 
    alpha = 0.7,
    position = position_dodge(width = 0.5)) +
  scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
  labs(subtitle = glue("Neutral vignettes 
(Evid.Ratio H1a > H1b = {round(h1a.neu$hypothesis$Evid.Ratio, 2)})"),
       x = NULL, 
       y = NULL) +
  scale_x_continuous(breaks = c(0, 1, 2, 3)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY") +
  theme(legend.position = "none")

neu_crt_plot

per_gng_plot <- m4.per.draws %>% 
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = commission_errors_r, y = draw_perc)) +
  stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) + 
  scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
  labs(subtitle = glue("Performance vignettes 
(Evid.Ratio H2a > H2b = {round(h2a.per$hypothesis$Evid.Ratio, 2)})"),
       x = NULL, 
       y = NULL) +
  scale_x_continuous(breaks = seq(15, 55, by = 10)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY"
                 ) +
  theme(legend.position = "none")

per_gng_plot

neu_gng_plot <- m4.neu.draws %>% 
  mutate(draw_perc = draw * 100) %>% 
  ggplot(aes(x = commission_errors_r, y = draw_perc)) +
  stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) + 
  scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
  labs(subtitle = glue("Neutral vignettes 
(Evid.Ratio H2a > H2b = {round(h2a.neu$hypothesis$Evid.Ratio, 2)})"),
       x = NULL, 
       y = NULL) +
  scale_x_continuous(breaks = seq(15, 55, by = 10)) +
  scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
                     labels = percent_format(scale = 1)) +
  theme_ipsum_rc(base_size = 14,
                 plot_title_size = 16,
                 axis_title_size = 14,
                 axis_text_size = 14,
                 grid = "XY"
                 ) +
  theme(legend.position = "none")

neu_gng_plot

Combined plot

top_panel <- pol_crt_plot + pol_gng_plot +
  plot_layout(ncol = 2, widths = c(1, 1))

bottom_left <- per_crt_plot + neu_crt_plot +
  plot_layout(heights = c(1, 1), widths = c(0.5, 0.5))

bottom_right <- per_gng_plot + neu_gng_plot +
  plot_layout(heights = c(1, 1), widths = c(1.5, 1.5))

cognitive_plot <- (top_panel / (bottom_left | bottom_right)) +
  plot_layout(heights = c(1.5, 2)) 

cognitive_plot

ggsave(here(fig_dir, "cognitive_fig.png"), width = 12, height = 10, dpi = 300)

Supplementary Table 3

Create a logit table with main parameters of interest of m2, m5, m6.

m2 table

h0a_mo.pol <- as_tibble(m2.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength > 0",
                      alpha = 0.025,
                      seed = 42)


h0a_mo.per <- as_tibble(m2.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength > 0",
                      alpha = 0.025,
                      seed = 42)

h0a_mo.neu <- as_tibble(m2.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength > 0",
                      alpha = 0.025,
                      seed = 42)

h0a_mo.pol$hypothesis$Evid.Ratio

[1] 92

h0a_mo.per$hypothesis$Evid.Ratio

[1] 614

h0a_mo.neu$hypothesis$Evid.Ratio

[1] 0.541

h0b_mo.pol <- as_tibble(m2.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength < 0",
             alpha = 0.025,
             seed = 42)


h0b_mo.per <- as_tibble(m2.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength < 0",
             alpha = 0.025,
             seed = 42)

h0b_mo.neu <- as_tibble(m2.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength < 0",
             alpha = 0.025,
             seed = 42)

h0b_mo.pol$hypothesis$Evid.Ratio

[1] 0.0109

h0b_mo.per$hypothesis$Evid.Ratio

[1] 0.00163

h0b_mo.neu$hypothesis$Evid.Ratio

[1] 1.85

m2.pol.logit <- describe_posterior(m2.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h0a_mo.pol$hypothesis$Evid.Ratio,
         "β < 0" = h0b_mo.pol$hypothesis$Evid.Ratio)

m2.per.logit <- describe_posterior(m2.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h0a_mo.per$hypothesis$Evid.Ratio,
         "β < 0" = h0b_mo.per$hypothesis$Evid.Ratio)

m2.neu.logit <- describe_posterior(m2.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h0a_mo.neu$hypothesis$Evid.Ratio,
         "β < 0" = h0b_mo.neu$hypothesis$Evid.Ratio)

m2.logit <- bind_rows(m2.pol.logit, m2.per.logit, m2.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "bsp_moideo_motive_strength") %>% 
  mutate(Parameter = "Motive strength") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m2.logit

Summary of Posterior Distribution

Question Type |       Parameter |    Median |    LL |   UL |  β > 0 |    β < 0
------------------------------------------------------------------------------
Political     | Motive strength |      0.07 |  0.01 | 0.14 |  92.02 |     0.01
Performance   | Motive strength |      0.06 |  0.02 | 0.12 | 614.38 | 2.00e-03
Neutral       | Motive strength | -8.00e-03 | -0.05 | 0.04 |   0.54 |     1.85

m5 table

h1a_mo.pol <- as_tibble(m5.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0",
                      alpha = 0.025,
                      seed = 42)

h1a_mo.per <- as_tibble(m5.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a_mo.neu <- as_tibble(m5.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a_mo.pol$hypothesis$Evid.Ratio

[1] 0.627

h1a_mo.per$hypothesis$Evid.Ratio

[1] 37.8

h1a_mo.neu$hypothesis$Evid.Ratio

[1] 0.684

h1b_mo.pol <- as_tibble(m5.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0",
             alpha = 0.025,
             seed = 42)

h1b_mo.per <- as_tibble(m5.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0", 
             alpha = 0.025,
             seed = 42)

h1b_mo.neu <- as_tibble(m5.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0", 
             alpha = 0.025,
             seed = 42)

h1b_mo.pol$hypothesis$Evid.Ratio

[1] 1.59

h1b_mo.per$hypothesis$Evid.Ratio

[1] 0.0264

h1b_mo.neu$hypothesis$Evid.Ratio

[1] 1.46

m5.pol.logit <- describe_posterior(m5.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h1a_mo.pol$hypothesis$Evid.Ratio,
         "β < 0" = h1b_mo.pol$hypothesis$Evid.Ratio)

m5.per.logit <- describe_posterior(m5.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h1a_mo.per$hypothesis$Evid.Ratio,
         "β < 0" = h1b_mo.per$hypothesis$Evid.Ratio)

m5.neu.logit <- describe_posterior(m5.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h1a_mo.neu$hypothesis$Evid.Ratio,
         "β < 0" = h1b_mo.neu$hypothesis$Evid.Ratio)

m5.logit <- bind_rows(m5.pol.logit, m5.per.logit, m5.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "bsp_moideo_motive_strength:scalecrt_correct") %>% 
  mutate(Parameter = "Motive strength x Cognitive Reflection") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m5.logit

Summary of Posterior Distribution

Question Type |                              Parameter |    Median |    LL |   UL | β > 0 | β < 0
-------------------------------------------------------------------------------------------------
Political     | Motive strength x Cognitive Reflection | -3.00e-03 | -0.03 | 0.02 |  0.63 |  1.59
Performance   | Motive strength x Cognitive Reflection |      0.05 |  0.00 | 0.12 | 37.84 |  0.03
Neutral       | Motive strength x Cognitive Reflection | -5.00e-03 | -0.05 | 0.04 |  0.68 |  1.46

m6 table

h2a_mo.pol <- as_tibble(m6.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a_mo.per <- as_tibble(m6.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0", 
                      alpha = 0.025,
                      seed = 42)

h2a_mo.neu <- as_tibble(m6.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a_mo.pol$hypothesis$Evid.Ratio

[1] 0.761

h2a_mo.per$hypothesis$Evid.Ratio

[1] 28.7

h2a_mo.neu$hypothesis$Evid.Ratio

[1] 0.169

h2b_mo.pol <- as_tibble(m6.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
             alpha = 0.025,
             seed = 42)

h2b_mo.per <- as_tibble(m6.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0", 
             alpha = 0.025,
             seed = 42)

h2b_mo.neu <- as_tibble(m6.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
             alpha = 0.025,
             seed = 42)

h2b_mo.pol$hypothesis$Evid.Ratio

[1] 1.31

h2b_mo.per$hypothesis$Evid.Ratio

[1] 0.0348

h2b_mo.neu$hypothesis$Evid.Ratio

[1] 5.93

m6.pol.logit <- describe_posterior(m6.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h2a_mo.pol$hypothesis$Evid.Ratio,
         "β < 0" = h2b_mo.pol$hypothesis$Evid.Ratio)

m6.per.logit <- describe_posterior(m6.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h2a_mo.per$hypothesis$Evid.Ratio,
         "β < 0" = h2b_mo.per$hypothesis$Evid.Ratio)

m6.neu.logit <- describe_posterior(m6.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h2a_mo.neu$hypothesis$Evid.Ratio,
         "β < 0" = h2a_mo.neu$hypothesis$Evid.Ratio)

m6.logit <- bind_rows(m6.pol.logit, m6.per.logit, m6.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "bsp_moideo_motive_strength:scalecommission_errors_r") %>% 
  mutate(Parameter = "Motive strength x Inhibitory Control") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m6.logit

Summary of Posterior Distribution

Question Type |                            Parameter |    Median |        LL |   UL | β > 0 | β < 0
---------------------------------------------------------------------------------------------------
Political     | Motive strength x Inhibitory Control | -2.00e-03 |     -0.03 | 0.02 |  0.76 |  1.31
Performance   | Motive strength x Inhibitory Control |      0.05 | -4.00e-03 | 0.11 | 28.74 |  0.04
Neutral       | Motive strength x Inhibitory Control |     -0.03 |     -0.09 | 0.02 |  0.17 |  0.17

Combined table

combined_mo_logit <- bind_rows(m2.logit, m5.logit, m6.logit) %>% 
  mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>% 
  arrange(`Question Type`, Parameter)

combined_mo_logit_table <- combined_mo_logit %>% 
  select(-c("Question Type")) %>% 
  tt() %>% 
  group_tt(
    i = list(
      "Political Vignettes" = 1,
      "Performance Vignettes" = 4,
      "Neutral Vignettes" = 7
    ),
    j = list(
      "95% CI" = 3:4,
      "Evidence Ratio" = 5:6))

combined_mo_logit_table %>% save_tt(here(table_dir, "combined_mo_logit_table.docx"), overwrite = TRUE)

combined_mo_logit_table

		95% CI		Evidence Ratio
Parameter	Median	LL	UL	β > 0	β < 0
Motive strength	0.068	0.012	0.135	92.023	0.011
Motive strength x Cognitive Reflection	-0.003	-0.031	0.019	0.627	1.595
Motive strength x Inhibitory Control	-0.002	-0.030	0.019	0.761	1.314
Motive strength	0.063	0.021	0.124	614.385	0.002
Motive strength x Cognitive Reflection	0.052	0.000	0.124	37.835	0.026
Motive strength x Inhibitory Control	0.046	-0.004	0.109	28.740	0.035
Motive strength	-0.008	-0.053	0.039	0.541	1.849
Motive strength x Cognitive Reflection	-0.005	-0.047	0.042	0.684	1.463
Motive strength x Inhibitory Control	-0.025	-0.087	0.020	0.169	0.169

Supplementary Figure 2

Extract draws

m2.pol.draws <- m2.pol %>% 
  epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                                    question_topic = levels(data_pol$question_topic)),
              re_formula = ~(ideo_motive|question_topic)) 

m2.per.draws <- m2.per %>% 
  epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                               question_topic = levels(data_per$question_topic)),
              re_formula = NA) 


m2.neu.draws <- m2.neu %>% 
  epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                               question_topic = levels(data_neu$question_topic)),
              re_formula = NA) 

m2.draws <- bind_rows(m2.pol.draws, m2.per.draws, m2.neu.draws) %>% 
  mutate(ideo_motive_strength = factor(ideo_motive_strength,
                                        levels = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                                        ordered = TRUE),
         question_topic = factor(question_topic, 
                        levels = c("climate",
                                   "immigration",
                                   "gender",
                                   "discrimination",
                                   "adoption",
                                   "punishment",
                                   "gonogo_performance",
                                   "fakenews_performance",
                                   "teaculture",
                                   "brain"),
                        labels = c("Anthropogenic climate change",
                                   "Immigrant population",
                                   "Gender stereotypes",
                                   "Racial discrimination",
                                   "Same-sex adoption",
                                   "Criminal reconviction",
                                   "Go / No-Go performance",
                                   "Fake News performance",
                                   "Tea with milk",
                                   "Brain proportion")))

Create figure

m2.draws %>% 
  mutate(perc = .epred * 100) %>% 
  ggplot(aes(x = perc, y = ideo_motive_strength, fill = ideo_motive_strength)) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 50, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  guides(fill = "none") +
  scale_fill_manual(values = rev(beyonce_palette(41, n = 6, 
                                             type = "continuous"))) +
  labs(title="Message Ratings by Motive Strength",
       x = "Coefficients", y = NULL,
       caption = "50% and 95% credible intervals shown in black") +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(15, 85),
                     breaks = seq(20, 80, by = 10)) +
  theme_ipsum_rc(base_size = 12,
                 plot_title_size = 14,
                 axis_title_size = 12,
                 axis_title_face = "bold",
                 axis_text_size = 12,
                 strip_text_size = 12,
                 strip_text_face = "bold"
                 ) + 
  facet_wrap(~question_topic, ncol = 2)

ggsave(here(fig_dir, "m2_perc_fig.png"), width = 8, height = 12, dpi = 300)